home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / cmpnew / cmpwt.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-03  |  4.6 KB  |  134 lines
  1. ;;; CMPWT  Output routines.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (defun wt-comment (message &optional (symbol nil))
  10.   (princ "
  11. /*    " *compiler-output1*)
  12.   (princ message *compiler-output1*)
  13.   (when symbol
  14.         (let ((s (symbol-name symbol)))
  15.              (declare (string s))
  16.              (dotimes** (n (length s))
  17.                         (let ((c (schar s n)))
  18.                              (declare (character c))
  19.                              (unless (char= c #\/)
  20.                                      (princ c *compiler-output1*))))))
  21.   (princ "    */
  22. " *compiler-output1*)
  23.   nil
  24.   )
  25.  
  26. (defun wt1 (form)
  27.   (cond ((or (stringp form) (integerp form) (characterp form))
  28.          (princ form *compiler-output1*))
  29.         ((or (typep form 'long-float)
  30.              (typep form 'short-float))
  31.          (format *compiler-output1* "~10,,,,,,'eG" form))
  32.         (t (wt-loc form)))
  33.   nil)
  34.  
  35. (defun wt-h1 (form)
  36.   (cond ((consp form)
  37.          (let ((fun (get (car form) 'wt)))
  38.               (if fun
  39.                   (apply fun (cdr form))
  40.                   (cmpiler-error "The location ~s is undefined." form))))
  41.         (t (princ form *compiler-output2*)))
  42.   nil)
  43.  
  44. (defun wt-data (expr)
  45.   (let ((*print-radix* nil)
  46.         (*print-base* 10)
  47.         (*print-circle* t)
  48.         (*print-pretty* nil)
  49.         (*print-level* nil)
  50.         (*print-length* nil)
  51.         (*print-case* :downcase)
  52.         (*print-gensym* t)
  53.         (*print-array* t)
  54.         (si::*print-package* t)
  55.         (si::*print-structure* t))
  56.     (terpri *compiler-output-data*)
  57.     (prin1 expr *compiler-output-data*)
  58.     nil))
  59.  
  60. (defun wt-data-begin ()
  61.   (princ "          " *compiler-output-data*)
  62.   (terpri *compiler-output-data*)
  63.   (princ "#(" *compiler-output-data*)
  64.   nil)
  65.  
  66. (defun wt-data-end ()
  67.   (terpri *compiler-output-data*)
  68.   (princ ")" *compiler-output-data*)
  69.   (terpri *compiler-output-data*)
  70.   nil)
  71.  
  72. (defun wt-data-package-operation (form)
  73.   (terpri *compiler-output-data*)
  74.   (princ "#!" *compiler-output-data*)
  75.   (wt-data form))
  76.  
  77. (defmacro wt (&rest forms &aux (fl nil))
  78.   (dolist** (form forms (cons 'progn (reverse (cons nil fl))))
  79.     (if (stringp form)
  80.         (push `(princ ,form *compiler-output1*) fl)
  81.         (push `(wt1 ,form) fl))))
  82.  
  83. (defmacro wt-h (&rest forms &aux (fl nil))
  84.   (cond ((endp forms) '(princ "
  85. " *compiler-output2*))
  86.         ((stringp (car forms))
  87.          (dolist** (form (cdr forms)
  88.                          (list* 'progn `(princ ,(concatenate 'string "
  89. " (car forms)) *compiler-output2*) (reverse (cons nil fl))))
  90.                    (if (stringp form)
  91.                        (push `(princ ,form *compiler-output2*) fl)
  92.                        (push `(wt-h1 ,form) fl))))
  93.         (t (dolist** (form forms
  94.                            (list* 'progn '(princ "
  95. " *compiler-output2*) (reverse (cons nil fl))))
  96.                      (if (stringp form)
  97.                          (push `(princ ,form *compiler-output2*) fl)
  98.                          (push `(wt-h1 ,form) fl))))))
  99.  
  100. (defmacro wt-nl (&rest forms &aux (fl nil))
  101.   (cond ((endp forms) '(princ "
  102.     " *compiler-output1*))
  103.         ((stringp (car forms))
  104.          (dolist** (form (cdr forms)
  105.                          (list* 'progn `(princ ,(concatenate 'string "
  106.     " (car forms)) *compiler-output1*) (reverse (cons nil fl))))
  107.                    (if (stringp form)
  108.                        (push `(princ ,form *compiler-output1*) fl)
  109.                        (push `(wt1 ,form) fl))))
  110.         (t (dolist** (form forms
  111.                            (list* 'progn '(princ "
  112.     " *compiler-output1*) (reverse (cons nil fl))))
  113.                      (if (stringp form)
  114.                          (push `(princ ,form *compiler-output1*) fl)
  115.                          (push `(wt1 ,form) fl))))))
  116.  
  117. (defmacro wt-nl1 (&rest forms &aux (fl nil))
  118.   (cond ((endp forms) '(princ "
  119. " *compiler-output1*))
  120.         ((stringp (car forms))
  121.          (dolist** (form (cdr forms)
  122.                          (list* 'progn `(princ ,(concatenate 'string "
  123. " (car forms)) *compiler-output1*) (reverse (cons nil fl))))
  124.                    (if (stringp form)
  125.                        (push `(princ ,form *compiler-output1*) fl)
  126.                        (push `(wt1 ,form) fl))))
  127.         (t (dolist** (form forms
  128.                            (list* 'progn '(princ "
  129. " *compiler-output1*) (reverse (cons nil fl))))
  130.                      (if (stringp form)
  131.                          (push `(princ ,form *compiler-output1*) fl)
  132.                          (push `(wt1 ,form) fl))))))
  133.  
  134.